home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / xcolorselect.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  3.4 KB  |  119 lines
  1. ; Simple color editor that only requires one extra color (useful for
  2. ; wimpy little PeeCee based systems, like mine, with only 16 colors)
  3. ;
  4. ; Author: Larry Campbell (campbell@redsox.bsw.com)
  5. ;
  6. (require (in-vicinity (library-vicinity) "x11.scm"))
  7. (require (in-vicinity (library-vicinity) "xt.scm"))
  8. (require (in-vicinity (library-vicinity) "xm.scm"))
  9. (require (in-vicinity (library-vicinity) "xmsubs.scm"))
  10. (require (in-vicinity (library-vicinity) "xevent.scm"))
  11.  
  12. (require 'format)
  13.  
  14. (define top-level
  15.   (if (defined? vs:top-level)
  16.       (xt:app-create-shell "xcolorfrob" "XColorfrob"
  17.                xt:application-shell
  18.                (xt:display vs:top-level))
  19.       (xt:initialize "xcolorfrob" "XColorfrob")))
  20.  
  21. (define xdisplay (xt:display top-level))
  22. (define cmap (x:default-colormap xdisplay 0))
  23. (define planes-n-colors (x:alloc-color-cells xdisplay cmap #f 0 1))
  24.  
  25. (if (not planes-n-colors)
  26.     (error "failed to allocate required color cell"))
  27.  
  28. (define pixel (caadr planes-n-colors))
  29. (x:store-color xdisplay cmap pixel 0 0 0)
  30.  
  31. (define panel (xt:create-managed-widget "panel" xm:row-column top-level))
  32.  
  33. (define button-panel
  34.   (xt:create-managed-widget "button-panel" xm:row-column panel))
  35.  
  36. (define color-panel
  37.   (xt:create-managed-widget "color-panel" xm:row-column panel))
  38.  
  39. (define (frob w)
  40.   (x:store-color xdisplay cmap pixel (red 'get) (green 'get) (blue 'get)))
  41.  
  42. (define (make-color name parent)
  43.   (let* ((widget
  44.       (xt:create-managed-widget
  45.        name xm:scale parent
  46.        xm:n-orientation xm:horizontal
  47.        xm:n-minimum 0
  48.        xm:n-maximum 65535
  49.        xm:n-value 0
  50.        xm:n-decimal-points 0
  51.        xm:n-show-value #t
  52.        xm:n-scale-width 150
  53.        xm:n-title-string (xm:string-create name))))
  54.     (xt:add-callback
  55.      widget xm:n-drag-callback frob)
  56.     (lambda (selector . args)        ; args not (yet) used
  57.       (case selector
  58.     ((get) (xt:get-value widget xm:n-value xt:integer))
  59.     ((set) (xt:set-values widget xm:n-value (car args)))
  60.     (else (error "invalid origin method" selector))))))
  61.  
  62. (define (pixel-truncate p)
  63.   (inexact->exact (truncate (* 4 (/ p 1024)))))
  64.  
  65. (define (emit port)
  66.   (let ((r (pixel-truncate (red 'get)))
  67.     (g (pixel-truncate (green 'get)))
  68.     (b (pixel-truncate (blue 'get))))
  69.     (format port "#~2,48X~2,48X~2,48X" r g b)))
  70.  
  71. (make-button "Set root" button-panel
  72.          (lambda (w)
  73.            (system (format #f "xsetroot -solid \"~A\"" (emit #f))))
  74.          '()
  75.          xm:n-alignment xm:alignment-center)
  76.  
  77. (make-button "Emit" button-panel
  78.          (lambda (w)
  79.            (emit #t)
  80.            (newline))
  81.          '()
  82.          xm:n-alignment xm:alignment-center)
  83.  
  84. (make-button "Quit" button-panel
  85.          (lambda (w)
  86.            (emit #t)
  87.            (newline)
  88.            (quit))
  89.          '()
  90.          xm:n-alignment xm:alignment-center)
  91.  
  92. (define red   (make-color "red"   color-panel))
  93. (define green (make-color "green" color-panel))
  94. (define blue  (make-color "blue"  color-panel))
  95.  
  96. (define box
  97.   (xt:create-managed-widget "box" xm:drawing-area color-panel
  98.                 xm:n-height 60))
  99.  
  100. (xt:add-event-handler
  101.  box x:exposure-mask 0
  102.  (lambda (widget e)
  103.    (let ((x (x:get-event-field e x:expose-event:x))
  104.      (y (x:get-event-field e x:expose-event:y))
  105.      (w (x:get-event-field e x:expose-event:width))
  106.      (h (x:get-event-field e x:expose-event:height)))
  107.      (x:fill-rectangle xdisplay (xt:window widget)
  108.                xgc x y w h))))
  109.  
  110. (define xgc
  111.   (x:create-gc xdisplay '() x:gc-background pixel x:gc-foreground pixel))
  112.  
  113. (xt:realize-widget top-level)
  114. (x:clear-area xdisplay (xt:window box) 0 0 0 0 #t)
  115.  
  116. (if (not (defined? vs:top-level))
  117.     (xt:main-loop))
  118.  
  119.